home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / scheme.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  38.7 KB  |  1,070 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "scheme.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Scheme evaluator package:
  8. ; ------------------------
  9.  
  10. ; This package contains a Scheme evaluator.
  11.  
  12. ;------------------------------------------------------------------------------
  13.  
  14. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  15.  
  16. (define (scheme-global-eval expr error)
  17.   (set! scheme-error error)
  18.   (scheme-eval expr))
  19.  
  20. (define (scheme-eval expr)
  21.   (let ((code (scheme-comp expr scheme-global-environment)))
  22.     (code #f)))
  23.  
  24. (define scheme-global-environment
  25.   (cons '()   ; environment chain
  26.         '())) ; macros
  27.  
  28. (define (scheme-add-macro name proc)
  29.   (set-cdr! scheme-global-environment
  30.     (cons (cons name proc) (cdr scheme-global-environment)))
  31.   name)
  32.  
  33. (define scheme-error '())
  34.  
  35. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  36.  
  37. (define scheme-syntactic-keywords
  38.   (list QUOTE-sym QUASIQUOTE-sym UNQUOTE-sym UNQUOTE-SPLICING-sym
  39.         LAMBDA-sym IF-sym SET!-sym COND-sym =>-sym ELSE-sym AND-sym OR-sym
  40.         CASE-sym LET-sym LET*-sym LETREC-sym BEGIN-sym DO-sym DEFINE-sym
  41.         **DEFINE-MACRO-sym))
  42.  
  43. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  44.  
  45. (define (scheme-comp expr env)
  46.  
  47. (define (push-frame frame env)
  48.   (if (null? frame)
  49.     env
  50.     (cons (cons (car env) frame) (cdr env))))
  51.  
  52. (define (lookup-var name env)
  53.   (let loop1 ((chain (car env)) (up 0))
  54.     (if (null? chain)
  55.       name
  56.       (let loop2 ((chain chain)
  57.                   (up up)
  58.                   (frame (cdr chain))
  59.                   (over 1))
  60.         (cond ((null? frame)
  61.                (loop1 (car chain) (+ up 1)))
  62.               ((eq? (car frame) name)
  63.                (cons up over))
  64.               (else
  65.                (loop2 chain up (cdr frame) (+ over 1))))))))
  66.  
  67. (define (macro? name env)
  68.   (assq name (cdr env)))
  69.  
  70. (define (push-macro name proc env)
  71.   (cons (car env) (cons (cons name proc) (cdr env))))
  72.  
  73. (define (lookup-macro name env)
  74.   (cdr (assq name (cdr env))))
  75.  
  76. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  77.  
  78. (define (variable x)
  79.   (if (not (symbol-object? x))
  80.     (scheme-error "Identifier expected" x))
  81.   (if (memq x scheme-syntactic-keywords)
  82.     (scheme-error "Variable name can not be a syntactic keyword" x)))
  83.  
  84. (define (shape form n)
  85.   (let loop ((form form) (n n) (l form))
  86.     (cond ((<= n 0))
  87.           ((pair? l)
  88.            (loop form (- n 1) (cdr l)))
  89.           (else
  90.            (scheme-error "Ill-constructed form" form)))))
  91.  
  92. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  93.  
  94. (define (macro-expand expr env)
  95.   (apply (lookup-macro (car expr) env) (cdr expr)))
  96.  
  97. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  98.  
  99. (define (comp-var expr env)
  100.   (variable expr)
  101.   (gen-var-ref (lookup-var expr env)))
  102.  
  103. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  104.  
  105. (define (comp-self-eval expr env)
  106.   (gen-cst expr))
  107.  
  108. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  109.  
  110. (define (comp-quote expr env)
  111.   (shape expr 2)
  112.   (gen-cst (cadr expr)))
  113.  
  114. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  115.  
  116. (define (comp-quasiquote expr env)
  117.   (comp-quasiquotation (cadr expr) 1 env))
  118.  
  119. (define (comp-quasiquotation form level env)
  120.   (cond ((= level 0)
  121.          (scheme-comp form env))
  122.         ((pair? form)
  123.          (cond
  124.            ((eq? (car form) QUASIQUOTE-sym)
  125.             (comp-quasiquotation-list form (+ level 1) env))
  126.            ((eq? (car form) UNQUOTE-sym)
  127.             (if (= level 1)
  128.               (scheme-comp (cadr form) env)
  129.               (comp-quasiquotation-list form (- level 1) env)))
  130.            ((eq? (car form) UNQUOTE-SPLICING-sym)
  131.             (if (= level 1)
  132.               (scheme-error "Ill-placed 'unquote-splicing'" form))
  133.             (comp-quasiquotation-list form (- level 1) env))
  134.            (else
  135.             (comp-quasiquotation-list form level env))))
  136.         ((vector? form)
  137.          (gen-vector-form
  138.            (comp-quasiquotation-list (vector->lst form) level env)))
  139.         (else
  140.          (gen-cst form))))
  141.  
  142. (define (comp-quasiquotation-list l level env)
  143.   (if (pair? l)
  144.     (let ((first (car l)))
  145.       (if (= level 1)
  146.         (if (unquote-splicing? first)
  147.           (begin
  148.             (shape first 2)
  149.             (gen-append-form (scheme-comp (cadr first) env)
  150.                              (comp-quasiquotation (cdr l) 1 env)))
  151.           (gen-cons-form (comp-quasiquotation first level env)
  152.                          (comp-quasiquotation (cdr l) level env)))
  153.         (gen-cons-form (comp-quasiquotation first level env)
  154.                        (comp-quasiquotation (cdr l) level env))))
  155.     (comp-quasiquotation l level env)))
  156.  
  157. (define (unquote-splicing? x)
  158.   (if (pair? x)
  159.     (if (eq? (car x) UNQUOTE-SPLICING-sym) #t #f)
  160.     #f))
  161.  
  162. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  163.  
  164. (define (comp-unquote expr env)
  165.   (scheme-error "Ill-placed 'unquote'" expr))
  166.  
  167. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  168.  
  169. (define (comp-unquote-splicing expr env)
  170.   (scheme-error "Ill-placed 'unquote-splicing'" expr))
  171.  
  172. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  173.  
  174. (define (comp-set! expr env)
  175.   (shape expr 3)
  176.   (variable (cadr expr))
  177.   (gen-var-set (lookup-var (cadr expr) env) (scheme-comp (caddr expr) env)))
  178.  
  179. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  180.  
  181. (define (comp-lambda expr env)
  182.   (shape expr 3)
  183.   (let ((parms (cadr expr)))
  184.     (let ((frame (parms->frame parms)))
  185.       (let ((nb-vars (length frame))
  186.             (code (comp-body (cddr expr) (push-frame frame env))))
  187.         (if (rest-param? parms)
  188.           (gen-lambda-rest nb-vars code)
  189.           (gen-lambda nb-vars code))))))
  190.  
  191. (define (parms->frame parms)
  192.   (cond ((null? parms)
  193.          '())
  194.         ((pair? parms)
  195.          (let ((x (car parms)))
  196.            (variable x)
  197.            (cons x (parms->frame (cdr parms)))))
  198.         (else
  199.          (variable parms)
  200.          (list parms))))
  201.  
  202. (define (rest-param? parms)
  203.   (cond ((pair? parms)
  204.          (rest-param? (cdr parms)))
  205.         ((null? parms)
  206.          #f)
  207.         (else
  208.          #t)))
  209.  
  210. (define (comp-body body env)
  211.  
  212.   (define (letrec-defines vars vals body env)
  213.     (if (pair? body)
  214.  
  215.       (let ((expr (car body)))
  216.         (cond ((not (pair? expr))
  217.                (letrec-defines* vars vals body env))
  218.               ((macro? (car expr) env)
  219.                (letrec-defines vars
  220.                                vals
  221.                                (cons (macro-expand expr env) (cdr body))
  222.                                env))
  223.               (else
  224.                (cond
  225.                  ((eq? (car expr) BEGIN-sym)
  226.                   (letrec-defines vars
  227.                                   vals
  228.                                   (append (cdr expr) (cdr body))
  229.                                   env))
  230.                  ((eq? (car expr) DEFINE-sym)
  231.                   (let ((x (definition-name expr)))
  232.                     (variable x)
  233.                     (letrec-defines (cons x vars)
  234.                                     (cons (definition-value expr) vals)
  235.                                     (cdr body)
  236.                                     env)))
  237.                  ((eq? (car expr) **DEFINE-MACRO-sym)
  238.                   (let ((x (definition-name expr)))
  239.                     (letrec-defines vars
  240.                                     vals
  241.                                     (cdr body)
  242.                                     (push-macro
  243.                                       x
  244.                                       (scheme-eval (definition-value expr))
  245.                                       env))))
  246.                  (else
  247.                   (letrec-defines* vars vals body env))))))
  248.  
  249.       (scheme-error "Body must contain at least one evaluable expression")))
  250.  
  251.   (define (letrec-defines* vars vals body env)
  252.     (if (null? vars)
  253.       (comp-sequence body env)
  254.       (comp-letrec-aux vars vals body env)))
  255.  
  256.   (letrec-defines '() '() body env))
  257.  
  258. (define (definition-name expr)
  259.   (shape expr 3)
  260.   (let ((pattern (cadr expr)))
  261.     (let ((name (if (pair? pattern) (car pattern) pattern)))
  262.       (if (not (symbol-object? name))
  263.         (scheme-error "Identifier expected" name))
  264.       name)))
  265.  
  266. (define (definition-value expr)
  267.   (let ((pattern (cadr expr)))
  268.     (if (pair? pattern)
  269.       (cons LAMBDA-sym (cons (cdr pattern) (cddr expr)))
  270.       (caddr expr))))
  271.  
  272. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  273.  
  274. (define (comp-if expr env)
  275.   (shape expr 3)
  276.   (let ((code1 (scheme-comp (cadr expr) env))
  277.         (code2 (scheme-comp (caddr expr) env)))
  278.     (if (pair? (cdddr expr))
  279.       (gen-if code1 code2 (scheme-comp (cadddr expr) env))
  280.       (gen-when code1 code2))))
  281.  
  282. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  283.  
  284. (define (comp-cond expr env)
  285.   (comp-cond-aux (cdr expr) env))
  286.  
  287. (define (comp-cond-aux clauses env)
  288.   (if (pair? clauses)
  289.     (let ((clause (car clauses)))
  290.       (shape clause 1)
  291.       (cond ((eq? (car clause) ELSE-sym)
  292.              (shape clause 2)
  293.              (comp-sequence (cdr clause) env))
  294.             ((not (pair? (cdr clause)))
  295.              (gen-or (scheme-comp (car clause) env)
  296.                      (comp-cond-aux (cdr clauses) env)))
  297.             ((eq? (cadr clause) =>-sym)
  298.              (shape clause 3)
  299.              (gen-cond-send (scheme-comp (car clause) env)
  300.                             (scheme-comp (caddr clause) env)
  301.                             (comp-cond-aux (cdr clauses) env)))
  302.             (else
  303.              (gen-if (scheme-comp (car clause) env)
  304.                      (comp-sequence (cdr clause) env)
  305.                      (comp-cond-aux (cdr clauses) env)))))
  306.     (gen-cst '())))
  307.  
  308. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  309.  
  310. (define (comp-and expr env)
  311.   (let ((rest (cdr expr)))
  312.     (if (pair? rest) (comp-and-aux rest env) (gen-cst #t))))
  313.  
  314. (define (comp-and-aux l env)
  315.   (let ((code (scheme-comp (car l) env))
  316.         (rest (cdr l)))
  317.     (if (pair? rest) (gen-and code (comp-and-aux rest env)) code)))
  318.  
  319. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  320.  
  321. (define (comp-or expr env)
  322.   (let ((rest (cdr expr)))
  323.     (if (pair? rest) (comp-or-aux rest env) (gen-cst #f))))
  324.  
  325. (define (comp-or-aux l env)
  326.   (let ((code (scheme-comp (car l) env))
  327.         (rest (cdr l)))
  328.     (if (pair? rest) (gen-or code (comp-or-aux rest env)) code)))
  329.  
  330. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  331.  
  332. (define (comp-case expr env)
  333.   (shape expr 3)
  334.   (gen-case (scheme-comp (cadr expr) env)
  335.             (comp-case-aux (cddr expr) env)))
  336.  
  337. (define (comp-case-aux clauses env)
  338.   (if (pair? clauses)
  339.     (let ((clause (car clauses)))
  340.       (shape clause 2)
  341.       (if (eq? (car clause) ELSE-sym)
  342.         (gen-case-else (comp-sequence (cdr clause) env))
  343.         (gen-case-clause (car clause)
  344.                          (comp-sequence (cdr clause) env)
  345.                          (comp-case-aux (cdr clauses) env))))
  346.     (gen-case-else (gen-cst '()))))
  347.  
  348. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  349.  
  350. (define (comp-let expr env)
  351.   (shape expr 3)
  352.   (let ((x (cadr expr)))
  353.     (cond ((symbol-object? x)
  354.            (shape expr 4)
  355.            (let ((y (caddr expr)))
  356.              (let ((proc (cons LAMBDA-sym (cons (bindings->vars y) (cdddr expr)))))
  357.                (scheme-comp (cons (list LETREC-sym (list (list x proc)) x)
  358.                                   (bindings->vals y))
  359.                             env))))
  360.           ((pair? x)
  361.            (scheme-comp (cons (cons LAMBDA-sym (cons (bindings->vars x) (cddr expr)))
  362.                               (bindings->vals x))
  363.                         env))
  364.           (else
  365.            (comp-body (cddr expr) env)))))
  366.  
  367. (define (bindings->vars bindings)
  368.   (if (pair? bindings)
  369.     (let ((binding (car bindings)))
  370.       (shape binding 2)
  371.       (let ((x (car binding)))
  372.         (variable x)
  373.         (cons x (bindings->vars (cdr bindings)))))
  374.     '()))
  375.  
  376. (define (bindings->vals bindings)
  377.   (if (pair? bindings)
  378.     (let ((binding (car bindings)))
  379.       (cons (cadr binding) (bindings->vals (cdr bindings))))
  380.     '()))
  381.  
  382. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  383.  
  384. (define (comp-let* expr env)
  385.   (shape expr 3)
  386.   (let ((bindings (cadr expr)))
  387.     (if (pair? bindings)
  388.       (scheme-comp (list LET-sym
  389.                          (list (car bindings))
  390.                          (cons LET*-sym (cons (cdr bindings) (cddr expr))))
  391.                    env)
  392.       (comp-body (cddr expr) env))))
  393.  
  394. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  395.  
  396. (define (comp-letrec expr env)
  397.   (shape expr 3)
  398.   (let ((bindings (cadr expr)))
  399.     (comp-letrec-aux (bindings->vars bindings)
  400.                      (bindings->vals bindings)
  401.                      (cddr expr)
  402.                      env)))
  403.  
  404. (define (comp-letrec-aux vars vals body env)
  405.   (if (pair? vars)
  406.     (let ((new-env (push-frame vars env)))
  407.       (gen-letrec (comp-vals vals new-env)
  408.                   (comp-body body new-env)))
  409.     (comp-body body env)))
  410.  
  411. (define (comp-vals l env)
  412.   (if (pair? l)
  413.     (cons (scheme-comp (car l) env) (comp-vals (cdr l) env))
  414.     '()))
  415.  
  416. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  417.  
  418. (define (comp-begin expr env)
  419.   (shape expr 2)
  420.   (comp-sequence (cdr expr) env))
  421.  
  422. (define (comp-sequence exprs env)
  423.   (if (pair? exprs)
  424.     (comp-sequence-aux exprs env)
  425.     (gen-cst '())))
  426.  
  427. (define (comp-sequence-aux exprs env)
  428.   (let ((code (scheme-comp (car exprs) env))
  429.         (rest (cdr exprs)))
  430.     (if (pair? rest) (gen-sequence code (comp-sequence-aux rest env)) code)))
  431.  
  432. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  433.  
  434. (define (comp-do expr env)
  435.   (shape expr 3)
  436.   (let ((bindings (cadr expr))
  437.         (exit (caddr expr)))
  438.     (shape exit 1)
  439.     (let* ((vars (bindings->vars bindings))
  440.            (new-env1 (push-frame '(#f) env))
  441.            (new-env2 (push-frame vars new-env1)))
  442.       (gen-letrec
  443.         (list
  444.           (gen-lambda
  445.             (length vars)
  446.             (gen-if
  447.               (scheme-comp (car exit) new-env2)
  448.               (comp-sequence (cdr exit) new-env2)
  449.               (gen-sequence
  450.                 (comp-sequence (cdddr expr) new-env2)
  451.                 (gen-combination
  452.                   (gen-var-ref '(1 . 1))
  453.                   (comp-vals (bindings->steps bindings) new-env2))))))
  454.         (gen-combination
  455.           (gen-var-ref '(0 . 1))
  456.           (comp-vals (bindings->vals bindings) new-env1))))))
  457.  
  458. (define (bindings->steps bindings)
  459.   (if (pair? bindings)
  460.     (let ((binding (car bindings)))
  461.       (cons (if (pair? (cddr binding)) (caddr binding) (car binding))
  462.             (bindings->steps (cdr bindings))))
  463.     '()))
  464.  
  465. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  466.  
  467. (define (comp-define expr env)
  468.   (shape expr 3)
  469.   (let ((pattern (cadr expr)))
  470.     (let ((x (if (pair? pattern) (car pattern) pattern)))
  471.       (variable x)
  472.       (gen-sequence
  473.         (gen-var-set (lookup-var x env)
  474.                      (scheme-comp (if (pair? pattern)
  475.                                     (cons LAMBDA-sym (cons (cdr pattern) (cddr expr)))
  476.                                     (caddr expr))
  477.                                   env))
  478.         (gen-cst x)))))
  479.  
  480. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  481.  
  482. (define (comp-define-macro expr env)
  483.   (let ((x (definition-name expr)))
  484.     (gen-macro x (scheme-eval (definition-value expr)))))
  485.  
  486. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  487.  
  488. (define (comp-combination expr env)
  489.   (gen-combination (scheme-comp (car expr) env) (comp-vals (cdr expr) env)))
  490.  
  491. ;------------------------------------------------------------------------------
  492.  
  493. (define (gen-var-ref var)
  494.   (if (pair? var)
  495.     (gen-rte-ref (car var) (cdr var))
  496.     (gen-glo-ref (scheme-global-var var))))
  497.  
  498. (define (gen-rte-ref up over)
  499.   (case up
  500.     ((0)  (gen-slot-ref-0 over))
  501.     ((1)  (gen-slot-ref-1 over))
  502.     (else (gen-slot-ref-up-2 (gen-rte-ref (- up 2) over)))))
  503.  
  504. (define (gen-slot-ref-0 i)
  505.   (case i
  506.     ((0)  (lambda (rte) (vector-ref rte 0)))
  507.     ((1)  (lambda (rte) (vector-ref rte 1)))
  508.     ((2)  (lambda (rte) (vector-ref rte 2)))
  509.     ((3)  (lambda (rte) (vector-ref rte 3)))
  510.     (else (lambda (rte) (vector-ref rte i)))))
  511.  
  512. (define (gen-slot-ref-1 i)
  513.   (case i
  514.     ((0)  (lambda (rte) (vector-ref (vector-ref rte 0) 0)))
  515.     ((1)  (lambda (rte) (vector-ref (vector-ref rte 0) 1)))
  516.     ((2)  (lambda (rte) (vector-ref (vector-ref rte 0) 2)))
  517.     ((3)  (lambda (rte) (vector-ref (vector-ref rte 0) 3)))
  518.     (else (lambda (rte) (vector-ref (vector-ref rte 0) i)))))
  519.  
  520. (define (gen-slot-ref-up-2 code)
  521.   (lambda (rte) (code (vector-ref (vector-ref rte 0) 0))))
  522.  
  523. (define (gen-glo-ref i)
  524.   (lambda (rte) (scheme-global-var-ref i)))
  525.  
  526. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  527.  
  528. (define (gen-cst val)
  529.   (case val
  530.     ((()) (lambda (rte) '()))
  531.     ((#f) (lambda (rte) #f))
  532.     ((#t) (lambda (rte) #t))
  533.     ((-2) (lambda (rte) -2))
  534.     ((-1) (lambda (rte) -1))
  535.     ((0)  (lambda (rte) 0))
  536.     ((1)  (lambda (rte) 1))
  537.     ((2)  (lambda (rte) 2))
  538.     (else (lambda (rte) val))))
  539.  
  540. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  541.  
  542. (define (gen-append-form code1 code2)
  543.   (lambda (rte) (append (code1 rte) (code2 rte))))
  544.  
  545. (define (gen-cons-form code1 code2)
  546.   (lambda (rte) (cons (code1 rte) (code2 rte))))
  547.  
  548. (define (gen-vector-form code)
  549.   (lambda (rte) (lst->vector (code rte))))
  550.  
  551. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  552.  
  553. (define (gen-var-set var code)
  554.   (if (pair? var)
  555.     (gen-rte-set (car var) (cdr var) code)
  556.     (gen-glo-set (scheme-global-var var) code)))
  557.  
  558. (define (gen-rte-set up over code)
  559.   (case up
  560.     ((0)  (gen-slot-set-0 over code))
  561.     ((1)  (gen-slot-set-1 over code))
  562.     (else (gen-slot-set-n (gen-rte-ref (- up 2) 0) over code))))
  563.  
  564. (define (gen-slot-set-0 i code)
  565.   (case i
  566.     ((0)  (lambda (rte) (vector-set! rte 0 (code rte))))
  567.     ((1)  (lambda (rte) (vector-set! rte 1 (code rte))))
  568.     ((2)  (lambda (rte) (vector-set! rte 2 (code rte))))
  569.     ((3)  (lambda (rte) (vector-set! rte 3 (code rte))))
  570.     (else (lambda (rte) (vector-set! rte i (code rte))))))
  571.  
  572. (define (gen-slot-set-1 i code)
  573.   (case i
  574.     ((0)  (lambda (rte) (vector-set! (vector-ref rte 0) 0 (code rte))))
  575.     ((1)  (lambda (rte) (vector-set! (vector-ref rte 0) 1 (code rte))))
  576.     ((2)  (lambda (rte) (vector-set! (vector-ref rte 0) 2 (code rte))))
  577.     ((3)  (lambda (rte) (vector-set! (vector-ref rte 0) 3 (code rte))))
  578.     (else (lambda (rte) (vector-set! (vector-ref rte 0) i (code rte))))))
  579.  
  580. (define (gen-slot-set-n up i code)
  581.   (case i
  582.     ((0)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 0 (code rte))))
  583.     ((1)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 1 (code rte))))
  584.     ((2)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 2 (code rte))))
  585.     ((3)  (lambda (rte) (vector-set! (up (vector-ref rte 0)) 3 (code rte))))
  586.     (else (lambda (rte) (vector-set! (up (vector-ref rte 0)) i (code rte))))))
  587.  
  588. (define (gen-glo-set i code)
  589.   (lambda (rte) (scheme-global-var-set! i (code rte))))
  590.  
  591. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  592.  
  593. (define (gen-lambda-rest nb-vars body)
  594.   (case nb-vars
  595.     ((1)  (gen-lambda-1-rest body))
  596.     ((2)  (gen-lambda-2-rest body))
  597.     ((3)  (gen-lambda-3-rest body))
  598.     (else (gen-lambda-n-rest nb-vars body))))
  599.  
  600. (define (gen-lambda-1-rest body)
  601.   (lambda (rte)
  602.     (lambda a
  603.       (let ((x (make-vector 2)))
  604.         (vector-set! x 0 rte)
  605.         (vector-set! x 1 a)
  606.         (body x)))))
  607.  
  608. (define (gen-lambda-2-rest body)
  609.   (lambda (rte)
  610.     (lambda (a . b)
  611.       (let ((x (make-vector 3)))
  612.         (vector-set! x 0 rte)
  613.         (vector-set! x 1 a)
  614.         (vector-set! x 2 b)
  615.         (body x)))))
  616.  
  617. (define (gen-lambda-3-rest body)
  618.   (lambda (rte)
  619.     (lambda (a b . c)
  620.       (let ((x (make-vector 4)))
  621.         (vector-set! x 0 rte)
  622.         (vector-set! x 1 a)
  623.         (vector-set! x 2 b)
  624.         (vector-set! x 3 c)
  625.         (body x)))))
  626.  
  627. (define (gen-lambda-n-rest nb-vars body)
  628.   (lambda (rte)
  629.     (lambda (a b c . d)
  630.       (let ((x (make-vector (+ nb-vars 1))))
  631.         (vector-set! x 0 rte)
  632.         (vector-set! x 1 a)
  633.         (vector-set! x 2 b)
  634.         (vector-set! x 3 c)
  635.         (let loop ((n nb-vars) (x x) (i 4) (l d))
  636.           (if (< i n)
  637.             (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))
  638.             (vector-set! x i l)))
  639.         (body x)))))
  640.  
  641. (define (gen-lambda nb-vars body)
  642.   (case nb-vars
  643.     ((0)  (gen-lambda-0 body))
  644.     ((1)  (gen-lambda-1 body))
  645.     ((2)  (gen-lambda-2 body))
  646.     ((3)  (gen-lambda-3 body))
  647.     (else (gen-lambda-n nb-vars body))))
  648.  
  649. (define (gen-lambda-0 body)
  650.   (lambda (rte)
  651.     (lambda ()
  652.       (body rte))))
  653.  
  654. (define (gen-lambda-1 body)
  655.   (lambda (rte)
  656.     (lambda (a)
  657.       (let ((x (make-vector 2)))
  658.         (vector-set! x 0 rte)
  659.         (vector-set! x 1 a)
  660.         (body x)))))
  661.  
  662. (define (gen-lambda-2 body)
  663.   (lambda (rte)
  664.     (lambda (a b)
  665.       (let ((x (make-vector 3)))
  666.         (vector-set! x 0 rte)
  667.         (vector-set! x 1 a)
  668.         (vector-set! x 2 b)
  669.         (body x)))))
  670.  
  671. (define (gen-lambda-3 body)
  672.   (lambda (rte)
  673.     (lambda (a b c)
  674.       (let ((x (make-vector 4)))
  675.         (vector-set! x 0 rte)
  676.         (vector-set! x 1 a)
  677.         (vector-set! x 2 b)
  678.         (vector-set! x 3 c)
  679.         (body x)))))
  680.  
  681. (define (gen-lambda-n nb-vars body)
  682.   (lambda (rte)
  683.     (lambda (a b c . d)
  684.       (let ((x (make-vector (+ nb-vars 1))))
  685.         (vector-set! x 0 rte)
  686.         (vector-set! x 1 a)
  687.         (vector-set! x 2 b)
  688.         (vector-set! x 3 c)
  689.         (let loop ((n nb-vars) (x x) (i 4) (l d))
  690.           (if (<= i n)
  691.             (begin (vector-set! x i (car l)) (loop n x (+ i 1) (cdr l)))))
  692.         (body x)))))
  693.  
  694. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  695.  
  696. (define (gen-sequence code1 code2)
  697.   (lambda (rte) (code1 rte) (code2 rte)))
  698.  
  699. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  700.  
  701. (define (gen-when code1 code2)
  702.   (lambda (rte)
  703.     (let ((temp (code1 rte)))
  704.       (if (false-object? temp)
  705.         '()
  706.         (code2 rte)))))
  707.  
  708. (define (gen-if code1 code2 code3)
  709.   (lambda (rte)
  710.     (let ((temp (code1 rte)))
  711.       (if (false-object? temp)
  712.         (code3 rte)
  713.         (code2 rte)))))
  714.  
  715. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  716.  
  717. (define (gen-cond-send code1 code2 code3)
  718.   (lambda (rte)
  719.     (let ((temp (code1 rte)))
  720.       (if (false-object? temp)
  721.         (code3 rte)
  722.         ((code2 rte) temp)))))
  723.               
  724. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  725.  
  726. (define (gen-and code1 code2)
  727.   (lambda (rte)
  728.     (let ((temp (code1 rte)))
  729.       (if (false-object? temp)
  730.         temp
  731.         (code2 rte)))))
  732.  
  733. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  734.  
  735. (define (gen-or code1 code2)
  736.   (lambda (rte)
  737.     (let ((temp (code1 rte)))
  738.       (if (false-object? temp)
  739.         (code2 rte)
  740.         temp))))
  741.  
  742. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  743.  
  744. (define (gen-case code1 code2)
  745.   (lambda (rte) (code2 rte (code1 rte))))
  746.  
  747. (define (gen-case-clause datums code1 code2)
  748.   (lambda (rte key) (if (memv key datums) (code1 rte) (code2 rte key))))
  749.  
  750. (define (gen-case-else code)
  751.   (lambda (rte key) (code rte)))
  752.  
  753. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  754.  
  755. (define (gen-letrec vals body)
  756.   (let ((nb-vals (length vals)))
  757.     (case nb-vals
  758.       ((1)  (gen-letrec-1 (car vals) body))
  759.       ((2)  (gen-letrec-2 (car vals) (cadr vals) body))
  760.       ((3)  (gen-letrec-3 (car vals) (cadr vals) (caddr vals) body))
  761.       (else (gen-letrec-n nb-vals vals body)))))
  762.  
  763. (define (gen-letrec-1 val1 body)
  764.   (lambda (rte)
  765.     (let ((x (make-vector 2)))
  766.       (vector-set! x 0 rte)
  767.       (vector-set! x 1 (val1 x))
  768.       (body x))))
  769.  
  770. (define (gen-letrec-2 val1 val2 body)
  771.   (lambda (rte)
  772.     (let ((x (make-vector 3)))
  773.       (vector-set! x 0 rte)
  774.       (vector-set! x 1 (val1 x))
  775.       (vector-set! x 2 (val2 x))
  776.       (body x))))
  777.  
  778. (define (gen-letrec-3 val1 val2 val3 body)
  779.   (lambda (rte)
  780.     (let ((x (make-vector 4)))
  781.       (vector-set! x 0 rte)
  782.       (vector-set! x 1 (val1 x))
  783.       (vector-set! x 2 (val2 x))
  784.       (vector-set! x 3 (val3 x))
  785.       (body x))))
  786.  
  787. (define (gen-letrec-n nb-vals vals body)
  788.   (lambda (rte)
  789.     (let ((x (make-vector (+ nb-vals 1))))
  790.       (vector-set! x 0 rte)
  791.       (let loop ((x x) (i 1) (l vals))
  792.         (if (pair? l)
  793.           (begin (vector-set! x i ((car l) x)) (loop x (+ i 1) (cdr l)))))
  794.       (body x))))
  795.  
  796. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  797.  
  798. (define (gen-macro name proc)
  799.   (lambda (rte) (scheme-add-macro name proc)))
  800.  
  801. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  802.  
  803. (define (gen-combination oper args)
  804.   (case (length args)
  805.     ((0)  (gen-combination-0 oper))
  806.     ((1)  (gen-combination-1 oper (car args)))
  807.     ((2)  (gen-combination-2 oper (car args) (cadr args)))
  808.     ((3)  (gen-combination-3 oper (car args) (cadr args) (caddr args)))
  809.     (else (gen-combination-n oper args))))
  810.  
  811. (define (gen-combination-0 oper)
  812.   (lambda (rte) ((oper rte))))
  813.  
  814. (define (gen-combination-1 oper arg1)
  815.   (lambda (rte) ((oper rte) (arg1 rte))))
  816.  
  817. (define (gen-combination-2 oper arg1 arg2)
  818.   (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte))))
  819.  
  820. (define (gen-combination-3 oper arg1 arg2 arg3)
  821.   (lambda (rte) ((oper rte) (arg1 rte) (arg2 rte) (arg3 rte))))
  822.  
  823. (define (gen-combination-n oper args)
  824.   (lambda (rte)
  825.     (define (evaluate l rte)
  826.       (if (pair? l)
  827.         (cons ((car l) rte) (evaluate (cdr l) rte))
  828.         '()))
  829.     (apply (oper rte) (evaluate args rte))))
  830.  
  831. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  832.  
  833.   (cond ((symbol-object? expr)
  834.          (comp-var expr env))
  835.         ((not (pair? expr))
  836.          (comp-self-eval expr env))
  837.         ((macro? (car expr) env)
  838.          (scheme-comp (macro-expand expr env) env))
  839.         (else
  840.          (cond
  841.            ((eq? (car expr) QUOTE-sym)            (comp-quote expr env))
  842.            ((eq? (car expr) QUASIQUOTE-sym)       (comp-quasiquote expr env))
  843.            ((eq? (car expr) UNQUOTE-sym)          (comp-unquote expr env))
  844.            ((eq? (car expr) UNQUOTE-SPLICING-sym) (comp-unquote-splicing expr env))
  845.            ((eq? (car expr) SET!-sym)             (comp-set! expr env))
  846.            ((eq? (car expr) LAMBDA-sym)           (comp-lambda expr env))
  847.            ((eq? (car expr) IF-sym)               (comp-if expr env))
  848.            ((eq? (car expr) COND-sym)             (comp-cond expr env))
  849.            ((eq? (car expr) AND-sym)              (comp-and expr env))
  850.            ((eq? (car expr) OR-sym)               (comp-or expr env))
  851.            ((eq? (car expr) CASE-sym)             (comp-case expr env))
  852.            ((eq? (car expr) LET-sym)              (comp-let expr env))
  853.            ((eq? (car expr) LET*-sym)             (comp-let* expr env))
  854.            ((eq? (car expr) LETREC-sym)           (comp-letrec expr env))
  855.            ((eq? (car expr) BEGIN-sym)            (comp-begin expr env))
  856.            ((eq? (car expr) DO-sym)               (comp-do expr env))
  857.            ((eq? (car expr) DEFINE-sym)           (comp-define expr env))
  858.            ((eq? (car expr) **DEFINE-MACRO-sym)   (comp-define-macro expr env))
  859.            (else                                  (comp-combination expr env)))))
  860.  
  861. )
  862.  
  863. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  864.  
  865. (define (scheme-global-var name)
  866.   (let ((x (assq name scheme-global-variables)))
  867.     (if x
  868.       x
  869.       (let ((y (cons name '())))
  870.         (set! scheme-global-variables (cons y scheme-global-variables))
  871.         y))))
  872.  
  873. (define (scheme-global-var-ref i)
  874.   (cdr i))
  875.  
  876. (define (scheme-global-var-set! i val)
  877.   (set-cdr! i val)
  878.   '())
  879.  
  880. (define scheme-global-variables '())
  881.  
  882. (define (scheme-norm-proc name value)
  883.   (scheme-global-var-set!
  884.     (scheme-global-var (string->canonical-symbol name))
  885.     value))
  886.  
  887. (define (scheme-bool-proc name value)
  888.   (scheme-norm-proc name
  889.     (lambda l (let ((x (apply value l))) (if x #t false-object)))))
  890.  
  891. (scheme-bool-proc "NOT"                            (lambda (x) (false-object? x)))
  892. (scheme-bool-proc "BOOLEAN?"                       (lambda (x) (or (eq? x #t) (false-object? x))))
  893. (scheme-bool-proc "EQV?"                           EQV?)
  894. (scheme-bool-proc "EQ?"                            EQ?)
  895. (scheme-bool-proc "EQUAL?"                         EQUAL?)
  896. (scheme-bool-proc "PAIR?"                          PAIR?)
  897. (scheme-norm-proc "CONS"                           CONS)
  898. (scheme-norm-proc "CAR"                            CAR)
  899. (scheme-norm-proc "CDR"                            CDR)
  900. (scheme-norm-proc "SET-CAR!"                       SET-CAR!)
  901. (scheme-norm-proc "SET-CDR!"                       SET-CDR!)
  902. (scheme-norm-proc "CAAR"                           CAAR)
  903. (scheme-norm-proc "CADR"                           CADR)
  904. (scheme-norm-proc "CDAR"                           CDAR)
  905. (scheme-norm-proc "CDDR"                           CDDR)
  906. (scheme-norm-proc "CAAAR"                          CAAAR)
  907. (scheme-norm-proc "CAADR"                          CAADR)
  908. (scheme-norm-proc "CADAR"                          CADAR)
  909. (scheme-norm-proc "CADDR"                          CADDR)
  910. (scheme-norm-proc "CDAAR"                          CDAAR)
  911. (scheme-norm-proc "CDADR"                          CDADR)
  912. (scheme-norm-proc "CDDAR"                          CDDAR)
  913. (scheme-norm-proc "CDDDR"                          CDDDR)
  914. (scheme-norm-proc "CAAAAR"                         CAAAAR)
  915. (scheme-norm-proc "CAAADR"                         CAAADR)
  916. (scheme-norm-proc "CAADAR"                         CAADAR)
  917. (scheme-norm-proc "CAADDR"                         CAADDR)
  918. (scheme-norm-proc "CADAAR"                         CADAAR)
  919. (scheme-norm-proc "CADADR"                         CADADR)
  920. (scheme-norm-proc "CADDAR"                         CADDAR)
  921. (scheme-norm-proc "CADDDR"                         CADDDR)
  922. (scheme-norm-proc "CDAAAR"                         CDAAAR)
  923. (scheme-norm-proc "CDAADR"                         CDAADR)
  924. (scheme-norm-proc "CDADAR"                         CDADAR)
  925. (scheme-norm-proc "CDADDR"                         CDADDR)
  926. (scheme-norm-proc "CDDAAR"                         CDDAAR)
  927. (scheme-norm-proc "CDDADR"                         CDDADR)
  928. (scheme-norm-proc "CDDDAR"                         CDDDAR)
  929. (scheme-norm-proc "CDDDDR"                         CDDDDR)
  930. (scheme-bool-proc "NULL?"                          NULL?)
  931. (scheme-bool-proc "LIST?"                          LIST?)
  932. (scheme-norm-proc "LIST"                           LIST)
  933. (scheme-norm-proc "LENGTH"                         LENGTH)
  934. (scheme-norm-proc "APPEND"                         APPEND)
  935. (scheme-norm-proc "REVERSE"                        REVERSE)
  936. (scheme-norm-proc "LIST-REF"                       LIST-REF)
  937. (scheme-bool-proc "MEMQ"                           MEMQ)
  938. (scheme-bool-proc "MEMV"                           MEMV)
  939. (scheme-bool-proc "MEMBER"                         MEMBER)
  940. (scheme-bool-proc "ASSQ"                           ASSQ)
  941. (scheme-bool-proc "ASSV"                           ASSV)
  942. (scheme-bool-proc "ASSOC"                          ASSOC)
  943. (scheme-bool-proc "SYMBOL?"                        (lambda (x) (symbol-object? x)))
  944. (scheme-norm-proc "SYMBOL->STRING"                 SYMBOL->STRING)
  945. (scheme-norm-proc "STRING->SYMBOL"                 STRING->SYMBOL)
  946. (scheme-bool-proc "NUMBER?"                        NUMBER?)
  947. (scheme-bool-proc "COMPLEX?"                       COMPLEX?)
  948. (scheme-bool-proc "REAL?"                          REAL?)
  949. (scheme-bool-proc "RATIONAL?"                      RATIONAL?)
  950. (scheme-bool-proc "INTEGER?"                       INTEGER?)
  951. (scheme-bool-proc "EXACT?"                         EXACT?)
  952. (scheme-bool-proc "INEXACT?"                       INEXACT?)
  953. (scheme-bool-proc "="                              =)
  954. (scheme-bool-proc "<"                              <)
  955. (scheme-bool-proc ">"                              >)
  956. (scheme-bool-proc "<="                             <=)
  957. (scheme-bool-proc ">="                             >=)
  958. (scheme-bool-proc "ZERO?"                          ZERO?)
  959. (scheme-bool-proc "POSITIVE?"                      POSITIVE?)
  960. (scheme-bool-proc "NEGATIVE?"                      NEGATIVE?)
  961. (scheme-bool-proc "ODD?"                           ODD?)
  962. (scheme-bool-proc "EVEN?"                          EVEN?)
  963. (scheme-norm-proc "MAX"                            MAX)
  964. (scheme-norm-proc "MIN"                            MIN)
  965. (scheme-norm-proc "+"                              +)
  966. (scheme-norm-proc "*"                              *)
  967. (scheme-norm-proc "-"                              -)
  968. (scheme-norm-proc "/"                              /)
  969. (scheme-norm-proc "ABS"                            ABS)
  970. (scheme-norm-proc "QUOTIENT"                       QUOTIENT)
  971. (scheme-norm-proc "REMAINDER"                      REMAINDER)
  972. (scheme-norm-proc "MODULO"                         MODULO)
  973. (scheme-norm-proc "GCD"                            GCD)
  974. (scheme-norm-proc "LCM"                            LCM)
  975. (scheme-norm-proc "NUMERATOR"                      NUMERATOR)
  976. (scheme-norm-proc "DENOMINATOR"                    DENOMINATOR)
  977. (scheme-norm-proc "FLOOR"                          FLOOR)
  978. (scheme-norm-proc "CEILING"                        CEILING)
  979. (scheme-norm-proc "TRUNCATE"                       TRUNCATE)
  980. (scheme-norm-proc "ROUND"                          ROUND)
  981. (scheme-norm-proc "RATIONALIZE"                    RATIONALIZE)
  982. (scheme-norm-proc "EXP"                            EXP)
  983. (scheme-norm-proc "LOG"                            LOG)
  984. (scheme-norm-proc "SIN"                            SIN)
  985. (scheme-norm-proc "COS"                            COS)
  986. (scheme-norm-proc "TAN"                            TAN)
  987. (scheme-norm-proc "ASIN"                           ASIN)
  988. (scheme-norm-proc "ACOS"                           ACOS)
  989. (scheme-norm-proc "ATAN"                           ATAN)
  990. (scheme-norm-proc "SQRT"                           SQRT)
  991. (scheme-norm-proc "EXPT"                           EXPT)
  992. (scheme-norm-proc "MAKE-RECTANGULAR"               MAKE-RECTANGULAR)
  993. (scheme-norm-proc "MAKE-POLAR"                     MAKE-POLAR)
  994. (scheme-norm-proc "REAL-PART"                      REAL-PART)
  995. (scheme-norm-proc "IMAG-PART"                      IMAG-PART)
  996. (scheme-norm-proc "MAGNITUDE"                      MAGNITUDE)
  997. (scheme-norm-proc "ANGLE"                          ANGLE)
  998. (scheme-norm-proc "EXACT->INEXACT"                 EXACT->INEXACT)
  999. (scheme-norm-proc "INEXACT->EXACT"                 INEXACT->EXACT)
  1000. (scheme-norm-proc "NUMBER->STRING"                 NUMBER->STRING)
  1001. (scheme-norm-proc "STRING->NUMBER"                 STRING->NUMBER)
  1002. (scheme-bool-proc "CHAR?"                          CHAR?)
  1003. (scheme-bool-proc "CHAR=?"                         CHAR=?)
  1004. (scheme-bool-proc "CHAR<?"                         CHAR<?)
  1005. (scheme-bool-proc "CHAR>?"                         CHAR>?)
  1006. (scheme-bool-proc "CHAR<=?"                        CHAR<=?)
  1007. (scheme-bool-proc "CHAR>=?"                        CHAR>=?)
  1008. (scheme-bool-proc "CHAR-CI=?"                      CHAR-CI=?)
  1009. (scheme-bool-proc "CHAR-CI<?"                      CHAR-CI<?)
  1010. (scheme-bool-proc "CHAR-CI>?"                      CHAR-CI>?)
  1011. (scheme-bool-proc "CHAR-CI<=?"                     CHAR-CI<=?)
  1012. (scheme-bool-proc "CHAR-CI>=?"                     CHAR-CI>=?)
  1013. (scheme-bool-proc "CHAR-ALPHABETIC?"               CHAR-ALPHABETIC?)
  1014. (scheme-bool-proc "CHAR-NUMERIC?"                  CHAR-NUMERIC?)
  1015. (scheme-bool-proc "CHAR-WHITESPACE?"               CHAR-WHITESPACE?)
  1016. (scheme-bool-proc "CHAR-LOWER-CASE?"               CHAR-LOWER-CASE?)
  1017. (scheme-norm-proc "CHAR->INTEGER"                  CHAR->INTEGER)
  1018. (scheme-norm-proc "INTEGER->CHAR"                  INTEGER->CHAR)
  1019. (scheme-norm-proc "CHAR-UPCASE"                    CHAR-UPCASE)
  1020. (scheme-norm-proc "CHAR-DOWNCASE"                  CHAR-DOWNCASE)
  1021. (scheme-bool-proc "STRING?"                        STRING?)
  1022. (scheme-norm-proc "MAKE-STRING"                    MAKE-STRING)
  1023. (scheme-norm-proc "STRING"                         STRING)
  1024. (scheme-norm-proc "STRING-LENGTH"                  STRING-LENGTH)
  1025. (scheme-norm-proc "STRING-REF"                     STRING-REF)
  1026. (scheme-norm-proc "STRING-SET!"                    STRING-SET!)
  1027. (scheme-bool-proc "STRING=?"                       STRING=?)
  1028. (scheme-bool-proc "STRING<?"                       STRING<?)
  1029. (scheme-bool-proc "STRING>?"                       STRING>?)
  1030. (scheme-bool-proc "STRING<=?"                      STRING<=?)
  1031. (scheme-bool-proc "STRING>=?"                      STRING>=?)
  1032. (scheme-bool-proc "STRING-CI=?"                    STRING-CI=?)
  1033. (scheme-bool-proc "STRING-CI<?"                    STRING-CI<?)
  1034. (scheme-bool-proc "STRING-CI>?"                    STRING-CI>?)
  1035. (scheme-bool-proc "STRING-CI<=?"                   STRING-CI<=?)
  1036. (scheme-bool-proc "STRING-CI>=?"                   STRING-CI>=?)
  1037. (scheme-norm-proc "SUBSTRING"                      SUBSTRING)
  1038. (scheme-norm-proc "STRING-APPEND"                  STRING-APPEND)
  1039. (scheme-bool-proc "VECTOR?"                        VECTOR?)
  1040. (scheme-norm-proc "MAKE-VECTOR"                    MAKE-VECTOR)
  1041. (scheme-norm-proc "VECTOR"                         VECTOR)
  1042. (scheme-norm-proc "VECTOR-LENGTH"                  VECTOR-LENGTH)
  1043. (scheme-norm-proc "VECTOR-REF"                     VECTOR-REF)
  1044. (scheme-norm-proc "VECTOR-SET!"                    VECTOR-SET!)
  1045. (scheme-bool-proc "PROCEDURE?"                     PROCEDURE?)
  1046. (scheme-norm-proc "APPLY"                          APPLY)
  1047. (scheme-norm-proc "MAP"                            MAP)
  1048. (scheme-norm-proc "FOR-EACH"                       FOR-EACH)
  1049. (scheme-norm-proc "CALL-WITH-CURRENT-CONTINUATION" CALL-WITH-CURRENT-CONTINUATION)
  1050. (scheme-norm-proc "CALL-WITH-INPUT-FILE"           CALL-WITH-INPUT-FILE)
  1051. (scheme-norm-proc "CALL-WITH-OUTPUT-FILE"          CALL-WITH-OUTPUT-FILE)
  1052. (scheme-bool-proc "INPUT-PORT?"                    INPUT-PORT?)
  1053. (scheme-bool-proc "OUTPUT-PORT?"                   OUTPUT-PORT?)
  1054. (scheme-norm-proc "CURRENT-INPUT-PORT"             CURRENT-INPUT-PORT)
  1055. (scheme-norm-proc "CURRENT-OUTPUT-PORT"            CURRENT-OUTPUT-PORT)
  1056. (scheme-norm-proc "OPEN-INPUT-FILE"                OPEN-INPUT-FILE)
  1057. (scheme-norm-proc "OPEN-OUTPUT-FILE"               OPEN-OUTPUT-FILE)
  1058. (scheme-norm-proc "CLOSE-INPUT-PORT"               CLOSE-INPUT-PORT)
  1059. (scheme-norm-proc "CLOSE-OUTPUT-PORT"              CLOSE-OUTPUT-PORT)
  1060. (scheme-bool-proc "EOF-OBJECT?"                    EOF-OBJECT?)
  1061. (scheme-norm-proc "READ"                           READ)
  1062. (scheme-norm-proc "READ-CHAR"                      READ-CHAR)
  1063. (scheme-norm-proc "PEEK-CHAR"                      PEEK-CHAR)
  1064. (scheme-norm-proc "WRITE"                          WRITE)
  1065. (scheme-norm-proc "DISPLAY"                        DISPLAY)
  1066. (scheme-norm-proc "NEWLINE"                        NEWLINE)
  1067. (scheme-norm-proc "WRITE-CHAR"                     WRITE-CHAR)
  1068.  
  1069. ;==============================================================================
  1070.